home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tkxcompat.c < prev   
Encoding:
C/C++ Source or Header  |  1993-11-20  |  11.3 KB  |  411 lines
  1. /*
  2.  * This is a hack to retain partial compatibility with shared library
  3.  * version 3.0 which was based on tclX7.1a-B5.
  4.  */
  5.  
  6. /*
  7.  * tkXshell.c
  8.  *
  9.  * Version of Tk main that is modified to build a wish shell with the Extended
  10.  * Tcl command set and libraries.  This makes it easier to use a different
  11.  * main.
  12.  *-----------------------------------------------------------------------------
  13.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  14.  *
  15.  * Permission to use, copy, modify, and distribute this software and its
  16.  * documentation for any purpose and without fee is hereby granted, provided
  17.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  18.  * Mark Diekhans make no representations about the suitability of this
  19.  * software for any purpose.  It is provided "as is" without express or
  20.  * implied warranty.
  21.  *-----------------------------------------------------------------------------
  22.  * $Id: tkXshell.c,v 3.0 1993/11/19 07:01:36 markd Rel $
  23.  *-----------------------------------------------------------------------------
  24.  */
  25.  
  26. /* 
  27.  * main.c --
  28.  *
  29.  *    This file contains the main program for "wish", a windowing
  30.  *    shell based on Tk and Tcl.  It also provides a template that
  31.  *    can be used as the basis for main programs for other Tk
  32.  *    applications.
  33.  *
  34.  * Copyright (c) 1990-1993 The Regents of the University of California.
  35.  * All rights reserved.
  36.  *
  37.  * Permission is hereby granted, without written agreement and without
  38.  * license or royalty fees, to use, copy, modify, and distribute this
  39.  * software and its documentation for any purpose, provided that the
  40.  * above copyright notice and the following two paragraphs appear in
  41.  * all copies of this software.
  42.  * 
  43.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  44.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  45.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  46.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  47.  *
  48.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  49.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  50.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  51.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  52.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  53.  */
  54.  
  55. #ifdef __cplusplus
  56. #    include "tcl++.h"
  57. #    include <unistd.h>
  58. #else
  59. #    include "tclExtend.h"
  60. #endif
  61.  
  62. #include "tk.h"
  63.  
  64. /*
  65.  * Declarations for various library procedures and variables (don't want
  66.  * to include tkInt.h or tkConfig.h here, because people might copy this
  67.  * file out of the Tk source directory to make their own modified versions).
  68.  */
  69.  
  70. extern void        exit _ANSI_ARGS_((int status));
  71. extern int        isatty _ANSI_ARGS_((int fd));
  72. extern int        read _ANSI_ARGS_((int fd, char *buf, size_t size));
  73. extern char *        strrchr _ANSI_ARGS_((CONST char *string, int c));
  74.  
  75. /*
  76.  * Global variables used by the main program:
  77.  */
  78.  
  79. static Tk_Window mainWindow;    /* The main window for the application.  If
  80.                  * NULL then the application no longer
  81.                  * exists. */
  82. static Tcl_Interp *interp;    /* Interpreter for this application. */
  83. extern char *tcl_RcFileName;    /* Name of a user-specific startup script
  84.                  * to source if the application is being run
  85.                  * interactively (e.g. "~/.wishrc").  Set
  86.                  * by Tcl_AppInit.  NULL means don't source
  87.                  * anything ever. */
  88. static Tcl_DString command;    /* Used to assemble lines of terminal input
  89.                  * into Tcl commands. */
  90. static int gotPartial = 0;      /* Partial command in buffer. */
  91. static int tty;            /* Non-zero means standard input is a
  92.                  * terminal-like device.  Zero means it's
  93.                  * a file. */
  94. static char exitCmd[] = "exit";
  95. static char errorExitCmd[] = "exit 1";
  96.  
  97. /*
  98.  * Command-line options:
  99.  */
  100.  
  101. static int synchronize = 0;
  102. static char *fileName = NULL;
  103. static char *name = NULL;
  104. static char *display = NULL;
  105. static char *geometry = NULL;
  106.  
  107. static Tk_ArgvInfo argTable[] = {
  108.     {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName,
  109.     "File from which to read commands"},
  110.     {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
  111.     "Initial geometry for window"},
  112.     {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
  113.     "Display to use"},
  114.     {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
  115.     "Name to use for application"},
  116.     {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
  117.     "Use synchronous mode for display server"},
  118.     {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
  119.     (char *) NULL}
  120. };
  121.  
  122. /*
  123.  * Forward declarations for procedures defined later in this file:
  124.  */
  125.  
  126. static void        StdinProc _ANSI_ARGS_((ClientData clientData,
  127.                 int mask));
  128. static void        SignalProc _ANSI_ARGS_((int signalNum));
  129.  
  130. /*
  131.  *----------------------------------------------------------------------
  132.  *
  133.  * TkX_Wish --
  134.  *
  135.  *    Main program for Wish.
  136.  *
  137.  * Results:
  138.  *    None. This procedure never returns (it exits the process when
  139.  *    it's done
  140.  *
  141.  * Side effects:
  142.  *    This procedure initializes the wish world and then starts
  143.  *    interpreting commands;  almost anything could happen, depending
  144.  *    on the script being interpreted.
  145.  *
  146.  *----------------------------------------------------------------------
  147.  */
  148.  
  149. void
  150. __TkX_Main (argc, argv)
  151.     int argc;                /* Number of arguments. */
  152.     char **argv;            /* Array of argument strings. */
  153. {
  154.     char *args, *p, *msg;
  155.     char buf[20];
  156.     int code;
  157.  
  158.     interp = Tcl_CreateInterp();
  159. #ifdef TCL_MEM_DEBUG
  160.     Tcl_InitMemory(interp);
  161. #endif
  162.  
  163.     /*
  164.      * Parse command-line arguments.
  165.      */
  166.  
  167.     if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0)
  168.         != TCL_OK) {
  169.     fprintf(stderr, "%s\n", interp->result);
  170.     exit(1);
  171.     }
  172.     if (name == NULL) {
  173.     if (fileName != NULL) {
  174.         p = fileName;
  175.     } else {
  176.         p = argv[0];
  177.     }
  178.     name = strrchr(p, '/');
  179.     if (name != NULL) {
  180.         name++;
  181.     } else {
  182.         name = p;
  183.     }
  184.     }
  185.  
  186.     /*
  187.      * If a display was specified, put it into the DISPLAY
  188.      * environment variable so that it will be available for
  189.      * any sub-processes created by us.
  190.      */
  191.  
  192.     if (display != NULL) {
  193.     Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY);
  194.     }
  195.  
  196.     /*
  197.      * Set the "tcl_interactive" variable.
  198.      */
  199.     tty = isatty(0);
  200.     Tcl_SetVar(interp, "tcl_interactive",
  201.          ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  202.  
  203.     tty = isatty(0);
  204.  
  205.     /*
  206.      * Initialize the Tk application.
  207.      */
  208.  
  209.     mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk");
  210.     if (mainWindow == NULL) {
  211.     fprintf(stderr, "%s\n", interp->result);
  212.     exit(1);
  213.     }
  214.     Tk_SetClass(mainWindow, "Tk");
  215.     if (synchronize) {
  216.     XSynchronize(Tk_Display(mainWindow), True);
  217.     }
  218.     Tk_GeometryRequest(mainWindow, 200, 200);
  219.  
  220.     /*
  221.      * Make command-line arguments available in the Tcl variables "argc"
  222.      * and "argv".  Also set the "geometry" variable from the geometry
  223.      * specified on the command line.
  224.      */
  225.  
  226.     args = Tcl_Merge(argc-1, argv+1);
  227.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  228.     ckfree(args);
  229.     sprintf(buf, "%d", argc-1);
  230.     Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
  231.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  232.         TCL_GLOBAL_ONLY);
  233.     if (geometry != NULL) {
  234.     Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY);
  235.     }
  236.  
  237.     /*
  238.      * Invoke application-specific initialization.
  239.      */
  240.  
  241.     if (__TclX_AppInit(interp) != TCL_OK) {
  242.     TclX_ErrorExit (interp, 255);
  243.     }
  244.  
  245.     /*
  246.      * Set the geometry of the main window, if requested.
  247.      */
  248.  
  249.     if (geometry != NULL) {
  250.     code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL);
  251.     if (code != TCL_OK) {
  252.         fprintf(stderr, "%s\n", interp->result);
  253.     }
  254.     }
  255.  
  256.     /*
  257.      * Invoke the script specified on the command line, if any.
  258.      */
  259.  
  260.     if (fileName != NULL) {
  261.     code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL);
  262.     if (code != TCL_OK) {
  263.         goto error;
  264.     }
  265.     tty = 0;
  266.     } else {
  267.         TclX_EvalRCFile (interp);
  268.  
  269.     /*
  270.      * Commands will come from standard input.  Set up a handler
  271.      * to receive those characters and print a prompt if the input
  272.      * device is a terminal.
  273.      */
  274.         tclErrorSignalProc = SignalProc;
  275.     Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0);
  276.     if (tty) {
  277.         TclX_OutputPrompt (interp, 1);
  278.     }
  279.     }
  280.     tclSignalBackgroundError = Tk_BackgroundError;
  281.  
  282.     fflush(stdout);
  283.     Tcl_DStringInit(&command);
  284.  
  285.     /*
  286.      * Loop infinitely, waiting for commands to execute.  When there
  287.      * are no windows left, Tk_MainLoop returns and we exit.
  288.      */
  289.  
  290.     Tk_MainLoop();
  291.  
  292.     /*
  293.      * Don't exit directly, but rather invoke the Tcl "exit" command.
  294.      * This gives the application the opportunity to redefine "exit"
  295.      * to do additional cleanup.
  296.      */
  297.  
  298.     Tcl_GlobalEval(interp, exitCmd);
  299.     exit(1);
  300.  
  301. error:
  302.     msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  303.     if (msg == NULL) {
  304.     msg = interp->result;
  305.     }
  306.     fprintf(stderr, "%s\n", msg);
  307.     Tcl_GlobalEval(interp, errorExitCmd);
  308.     exit (1);
  309.     return 1;   /* Needed only to prevent compiler warnings. */
  310. }
  311.  
  312. /*
  313.  *----------------------------------------------------------------------
  314.  *
  315.  * SignalProc --
  316.  *
  317.  *    Function called on a signal generating an error to clear the stdin
  318.  *       buffer.
  319.  *----------------------------------------------------------------------
  320.  */
  321.  
  322. static void
  323. SignalProc (signalNum)
  324.     int  signalNum;
  325. {
  326.     tclGotErrorSignal = 0;
  327.     Tcl_DStringFree (&command);
  328.     gotPartial = 0;
  329.     if (tty) {
  330.         fputc ('\n', stdout);
  331.         TclX_OutputPrompt (interp, !gotPartial);
  332.     }
  333. }
  334.  
  335. /*
  336.  *----------------------------------------------------------------------
  337.  *
  338.  * StdinProc --
  339.  *
  340.  *    This procedure is invoked by the event dispatcher whenever
  341.  *    standard input becomes readable.  It grabs the next line of
  342.  *    input characters, adds them to a command being assembled, and
  343.  *    executes the command if it's complete.
  344.  *
  345.  * Results:
  346.  *    None.
  347.  *
  348.  * Side effects:
  349.  *    Could be almost arbitrary, depending on the command that's
  350.  *    typed.
  351.  *
  352.  *----------------------------------------------------------------------
  353.  */
  354.  
  355. static void
  356. StdinProc(clientData, mask)
  357.     ClientData clientData;        /* Not used. */
  358.     int mask;                /* Not used. */
  359. {
  360. #define BUFFER_SIZE 4000
  361.     char input[BUFFER_SIZE+1];
  362.     char *cmd;
  363.     int code, count;
  364.  
  365.     count = read(fileno(stdin), input, BUFFER_SIZE);
  366.     if (count <= 0) {
  367.     if (!gotPartial) {
  368.         if (tty) {
  369.         Tcl_VarEval(interp, "exit", (char *) NULL);
  370.         exit(1);
  371.         } else {
  372.         Tk_DeleteFileHandler(0);
  373.         }
  374.         return;
  375.     } else {
  376.         count = 0;
  377.     }
  378.     }
  379.     cmd = Tcl_DStringAppend(&command, input, count);
  380.     if (count != 0) {
  381.     if ((input[count-1] != '\n') && (input[count-1] != ';')) {
  382.         gotPartial = 1;
  383.         goto exitPoint;
  384.     }
  385.     if (!Tcl_CommandComplete(cmd)) {
  386.         gotPartial = 1;
  387.         goto exitPoint;
  388.     }
  389.     }
  390.     gotPartial = 0;
  391.  
  392.     /*
  393.      * Disable the stdin file handler;  otherwise if the command
  394.      * re-enters the event loop we might process commands from
  395.      * stdin before the current command is finished.  Among other
  396.      * things, this will trash the text of the command being evaluated.
  397.      */
  398.  
  399.     Tk_CreateFileHandler(0, 0, StdinProc, (ClientData) 0);
  400.     code = Tcl_RecordAndEval(interp, cmd, 0);
  401.     Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0);
  402.     if (tty)
  403.         TclX_PrintResult (interp, code, cmd);
  404.     Tcl_DStringFree(&command);
  405.  
  406.   exitPoint:
  407.     if (tty) {
  408.         TclX_OutputPrompt (interp, !gotPartial);
  409.     }
  410. }
  411.